COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	               D O C T O R   .   V L I                    
C00004 00003
C00011 00004	(SETQ PUNCTUATION 
C00012 00005	(MAPC '(
C00017 ENDMK
C⊗;
;               D O C T O R   .   V L I                    ;
;                                                          ;
;       Un vrai psychiatre pour le prix derisoire          ;
;----------------------------------------------------------;
;       Jerome CHAILLOUX                                   ;
;                                                          ;
;       Universite de Paris VIII - Vincennes               ;
;       Route de la Tourelle 75012 Paris                   ;
;       Tel : 374 12 50 poste 299                          ;
;                                                          ;
;       I.R.C.A.M.                                         ;
;       31 Rue St Merri 75004 Paris                        ;
;       Tel : 277 12 33 poste 48-48                        ;
;----------------------------------------------------------;

(DE ADVANCE ()
   (RPLACA (CDAR RULES) (COND ((NULL (CDADAR RULES)) 
				(CDDAR RULES))
			      ((CDADAR RULES)))))))

(DE ANALYSE ()
   (PROG (RULES PARSELIST DECOMP)
	(SETQ KEYSTACK (APPEND KEYSTACK
	   (LIST (GET 'NONE (COND ((ZEROP 
		(SETQ FLIPFLOP (DIFFER 2 FLIPFLOP))) 'MEM)
		('LASTRESORT))))))
   A (SETQ RULES (GET (CAR  KEYSTACK) 'RULES))
   B (SETQ DECOMP (CAAR (COND
	((ATOM (CAR RULES)) (SETQ RULES (GET (CAR RULES) 'RULES)))
	(RULES))))
      (SETQ PARSELIST NIL)
      (COND
	((NOT (TEST DECOMP SENTENCE)) (SETQ RULES (CDR RULES)))
	((AND (NOT (ATOM (CAR (SETQ RULES (CAR (ADVANCE))))))
		(NOT (EQ (CAAR RULES) 'PRE)))
	  (RETURN (SENTPRINT (RECONSTRUCT (CAR RULES)))))
	((NOT (ATOM (CAR RULES)))
	  (SETQ SENTENCE (RECONSTRUCT (CADAR RULES)))
	  (SETQ RULES (CDDAR RULES)))
	((EQ (CAR RULES) 'NEWKEY)
	 (SETQ KEYSTACK (CDR KEYSTACK)) (GO A))) (GO B))) )))

(DE BREAKANALYSE ()
   (COND ((EQ LETTER \15) (SETQ FLAG TERMINAL) (SETQ TERMINAL T))
	((AND (SETQ FLAG (MEMQ LETTER PUNCTUATION)) KEYSTACK) (GOBBLE))
	(FLAG (SETQ SENTENCE (SETQ FLAG NIL)))
	((NOT (EQ LETTER \12)) (SETQ TERMINAL  NIL)))) )))

(DE CLEANUP ()
   (PRINT "ACHTUNG CLEANUP"))))))

(DE GOBBLE ()
   (PROG ()
A	(SETQ LETTER (TYI))
	(BREAKANALYSE)
	(IF (NOT FLAG) (GO A)))) )))

(DE INITIALIZE ()
   (PROG ()
	(SETQ $OBLIST (OBLIST)) (SETQ SENTENCE (SETQ KEYSTACK NIL))))))))

(DE MAKESENTENCE ()
   (SETQ SENTENCE (CONS (COND ((SETQ FLAG (GET WORD 'TRANSLATION)) FLAG)
			(WORD)) SENTENCE))) )))

(DE MEMORY ()
   (PROG (PARSELIST X)
	(COND ((AND (SETQ RULES (GET (CAR KEYSTACK) 'MEMR))
		(TEST (CAAR RLES) SENTENCE))
	   (RPLACA (SETQ X (CDAR (GET (GET 'NONE 'MEM) 'RULES)))
		(APPEND (CAR X) (LIST (RECONSTRUCT (CAAR (ADVANCE))))))))))))))

(DE READIN ()
   (PROG (WORD LETTER FLAG TERMINAL)
A	(COND ((NULL (READWORD)) (GO B)))
	(MAKESENTENCE)
	(SETKEYSTACK)
	(SETQ TERMINAL NIL)
B	(BREAKANALYSE)
	(COND ((NOT FLAG) (GO A)))
	(SETQ SENTENCE (FREVERSE SENTENCE)))) )))

(DE READWORD ()
   (PROG ()
	(SETQ WORD NIL)
A	
	(COND
	   ((SETQ FLAG (MEMQ (SETQ LETTER (TYI)) BREAKLIST))
	     (RETURN (COND (WORD (SETQ WORD 
		(APPLY 'GENSYM (MAPCAR (REVERSE WORD) 'ASCII))))))))
             (SETQ WORD (CONS LETTER WORD))
	    (GO A))) ))))

(DE RECONSTRUCT (R)
   (COND
	((NULL R) NIL)
	((NUMBP (CAR R))
	  (APPEND (RECO1 (CAR R) PARSELIST) (RECONSTRUCT (CDR R))))
	((CONS (CAR R) (RECONSTRUCT (CDR R)))))) )))

(DE RECO1 (X P) (CAR (NTH P X))))))

(DE SENTPRINT (ANS)
   (TERPRI) (MAPC ANS 'PRIN1) (TERPRI)
   (TERPRI) (MEMORY)))))))

(DE SETKEYSTACK ()
   (COND
	((AND (SETQ FLAG (GET WORD 'PRIORITY)) KEYSTACK
		(GT FLAG (GET (CAR KEYSTACK) 'PRIORITY)))
	  (SETQ KEYSTACK (CONS WORD KEYSTACK)))
        (FLAG (SETQ KEYSTACK (APPEND KEYSTACK (LIST WORD)))))))))))

(DE TEST (D S)
   (PROG ()
G    (COND
	((NULL D) (RETURN (COND ((NOT S) (SETQ PARSELIST 
				(REVERSE PARSELIST))))))
	((NOT (COND ((NUMBP (CAR D))
	   (COND ((ZEROP (CAR D)) (TEST5)) ((TEST3 (CAR D) NIL))))
	((TEST4 (CAR D)) (TEST2))))
	(RETURN NIL)))
	(SETQ D (CDR D))
	(GO G))) ))))

(DE TEST1 (PROPL X)
    (COND
	((NULL PROPL) NIL)
	((GET X (CAR PROPL)) T)
	((TEST1 (CDR PROPL) X)))) )))

(DE TEST2 () (PROG ()
   (SETQ PARSELIST (CONS (LIST (CAR S)) PARSELIST))
   (SETQ S (CDR S))
   (RETURN T))) )))

(DE TEST3 (X L)
   (COND
	((ZEROP X) (SETQ PARSELIST (CONS (REVERSE L) PARSELIST)))
    	(S (TEST3 (SUB1 X) (CONS (CAR S) (PROGN (SETQ S (CDR S)) L))))))))))))

(DE TEST4 (D)
   (COND ((NULL S) NIL)
	((ATOM D) (EQ D (CAR S)))
	((CAR D) (MEMBER (CAR S) D))
	((TEST1 (CDR D) (CAR S))))) )))

(DE TEST5 () (PROG (L X)
   (COND
	((NULL (CDR D)) (SETQ PARSELIST (CONS S PARSELIST))
			(RETURN (NOT (SETQ S NIL)))))
A	(COND
	  ((SETQ X (PROG (PARSELIST) (RETURN (TEST (CDR D) S))))
	   (SETQ D (LIST (SETQ S NIL)))
	   (RETURN (SETQ PARSELIST (REVERSE (CONS (REVERSE L) X) 
			PARSELIST))))
	((AND (SETQ L (CONS (CAR S) L)) (SETQ S (CDR S))) (GO A))))) )))

(DE WORKER () (PROG (SENTENCE $OBLIST KEYSTACK)
   (WHILE T 
	(INITIALIZE)
	(READIN)
	(ANALYSE)
	(TERPRI)
	(PRINT "CLEANUP")
	(CLEANUP))))


(SETQ PUNCTUATION 
   (MAPCAR '(/? /! /: /. /, /; /( /) /' /- )
	   (LAMBDA (L) (CASCII L))))

(SETQ BREAKLIST (APPEND PUNCTUATION [\40 \11 \12 \13 \14 \15]))))

(SETQ DOCTOR '(
   AVANCE ANALYSE BREAKANALYSE CLEANUP INITIALIZE MAKESENTENCE
   MEMORY READIN READWORD RECONSTRUCT SENTPRINT SETKEYSTACK
   TEST TEST1 TEST2 TEST3 TEST4 TEST5 WORKER))

(SETQ FLIPFLOP 2)

(SETQ LETTER ())

(SETQ WORD ())

(DF DOCTORTRACE ()
   (TRACE ADVANCE ANALYSE BREAKANALYSE CLEANUP GOBBLE INITIALISE
    MAKESENTENCE MEMORY READIN READWORD RECONSTRUCT RECO1
    SENTPRINT SETKEYSTACK TEST TEST1 TEST2 TEST3 TEST4 TEST5 WORKER)))
(MAPC '(
	(VOUS . JE)
	(ETAIENT . ETAIT)
	(MAMAN . MERE)
	(JE . VOUS)
	(PAPA . PERE)
	(MON . VOTRE)
	(VOUS-MEME . MOI-MEME)
       ) (LAMBDA (L) (PUT (CAR L) (CDR L) 'TRANSLATION))))))

(MAPC '(
	(QUOI . 0)
	(QU . 0)
	(QUE . 0)

	(VOUS . 0)

	(EST . 0)
	(QUAND . 0)
	(NOM . 17)
	(TOUJOURS . 1)
	(PARCEQUE . 0)
	(OH . 12)
       ) (LAMBDA (L) (PUT (CAR L) (CDR L) 'PRIORITY))))))


(MAPC '(QUOI QUE QU) (LAMBDA (L) (PUT L
   '(((0) (NIL)
	(Pourquoi demandez vous cela ?)
	(Cette question vous interesse ?)
	(Qu'est-ce-que vous voulez vraiment savoir ?)))
    'RULES)))))))

(PUT 'VOUS
   '(((0 je vous rappelle 0) (NIL) DIT)
     ((0 je etes 0 vous 0) (NIL) (PRE (1 2 3 4) vous))
     ((0 je 0 etes 0) (NIL)
	(qu'est-ce-que cela vous fait de penser que je suis 5)
	(cela vous plait-il de croire que je suis 5)
	(Peut-etre aimeriez-vous etre 5)
	(Aimeriez-vous parfois etre 5))
     ((0 je 0 vous) (NIL)
	(Pourquoi pensez-vous que je 3 vous ?)
	(Vous aimeriez croire que je 3 vous, n'est-ce-pas ?)
	(y-a-t-il quelqu'un d'autre qui croit que je 3 vous ?))
     ((0 je 1 0) (NIL)
	(Nous parlons de vous, non de moi.)
	(Oh, je 3 4)
	(Vous ne parlez pas vraiment de moi, n'est-ce-pas ?)
	(Comment vous sentez-vous maintenant ?))
     ((0) (NIL) NEWKEY))
   'RULES))))

(PUT 'EST 
   '(((1 0 EST 1 0) (NIL)
	(Supposez que 1 2 ne soit pas 4 5)
	(Peut-etre que 1 2 est vraiment 4 5)
	(Parlez-moi plus de 1 2))
     ((0) (NIL) NEWKEY))
    'RULES)

(PUT 'QUAND '(QUOI) 'RULES)

(PUT 'NOM '(((0) (NIL)
	(Je ne suis pas interesse par les noms.)
	(Je vous ai deja dit que je n'etais pas 
	 interesse par les noms.)))
     'RULES)

(PUT 'ZZYYXX '(((0) (NIL) NEWKEYS)) 'RULES)

(PUT 'TOUJOURS 
   '(((0) (NIL)
	(Pouvez-vous me donner un exemple precis ?)
	(Quand ?)
	(A quel incident pensez-vous ?)
	(Vraiment toujours ?)))
     'RULES)

(PUT 'PARCEQUE
   '(((0) (NIL)
	(Est-ce vraiment la raison ?)
	(Ne pensez-vous pas a d'autres raisons ?)
	(est-ce que cette raison peut expliquer quelquechose d'autre ?)
     )) 'RULES)

(PUT 'OH 
   '(((0 mon 0H mon 0) (NIL) (PRE (1 mon-OH-mon 5) ZZYYXX))
     ((0 OH mon 0) (NIL) (PRE (1 OH-mom 4) ZZYYXX))
     ((0) (NIL) NEWKEY))
   'RULES)

(MAPC '(PEUX PEUT POUVONS POUVEZ PEUVENT) (LAMBDA (L) (PUT L
   '(((0 puis je 0) (NIL)
	(Vous croyez que je peux 4 n'est-ce-pas ?)
	QUOI
	(Vous voudriez que je sois capable de 4 ?)
	(Peut-etre vous aimeriez etre capable de 4 vous-meme ?))
      ((0 pouvez vous 0) (NIL)
	(voulez-vous etre capable de 4)
	(Peut-etre vous ne voulez pas 4)
	QUOI)
      ((0) (NIL) NEWKEY))
     'RULES)

(PUT 'L20605 '(((0) (NIL) L31405)) 'RULES)

(PUT 'L31405
   '(((0) (NIL)
	(JE NE VOUS COMPREND PAS VRAIMENT)
	(Continuez je vous prie.)
	(Qu'est-ce-que cela vous suggere ?)
	(Ca vous plait de discuter de ca ?!?)))
   'RULES)
(PUT 'NONE 'L20605 'MEM)